home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / PowerLisp 1.01 / Library / compiler.lisp < prev    next >
Encoding:
Text File  |  1993-08-27  |  38.8 KB  |  1,570 lines  |  [TEXT/ROSA]
  1. ;
  2. ;        Copyright © 1993 Roger Corman. All rights reserved.
  3. ;
  4.  
  5. ;
  6. ;    Source code for compiler.
  7. ;    This is included in the "COMPILER" package.
  8. ;
  9.  
  10. (provide :compiler)
  11. (in-package :compiler)
  12.  
  13. (export '(compile-top-level-form))
  14.     
  15. (require :assembler)
  16. (use-package :assembler)
  17.  
  18. (defvar *assemble-code* t)
  19.  
  20. (defun compile (name &optional lambda &aux (macro nil))
  21.     "Usage: (COMPILE function-name &optional lambda)"
  22.     (unless (typep name 'symbol) (error "Function name expected"))
  23.     (unless lambda (setf lambda (function-definition (symbol-function name))))
  24.     (setq macro (macro-function name))
  25.     (unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
  26.     (setq *assemble-code* t)
  27.     (if macro
  28.         (setf (macro-function name) (compile-lambda lambda name))
  29.         (setf (symbol-function name) (compile-lambda lambda name)))
  30.     name)
  31.  
  32. (defun compile-without-assembling (name &optional lambda &aux (macro nil))
  33.     "Usage: (COMPILE-WITHOUT-ASSEMBLING function-name &optional lambda)"
  34.     (unless (typep name 'symbol) (error "Function name expected"))
  35.     (unless lambda (setf lambda (function-definition (symbol-function name))))
  36.     (setq macro (macro-function name))
  37.     (unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
  38.     (setq *assemble-code* nil)
  39.     (compile-lambda lambda name))
  40.  
  41. (defun compile-file (input-file output-file print)
  42.     "Usage: (COMPILE-FILE input-filename :OUTPUT-FILE output-filename)"
  43.     (setq *assemble-code* t)
  44.     (do* ((infile (open input-file)) 
  45.           (outfile (open output-file))
  46.           (input-expression (read infile) (read infile))
  47.           code
  48.           return-value)
  49.          ((eq input-expression 'Eof) 
  50.             (close infile)
  51.             (set-file-type outfile "FASL")
  52.             (close outfile)
  53.             output-file)
  54.          (setq code (compile-top-level-form input-expression))
  55.          (%write-code-to-stream code outfile)
  56.          (setq return-value (funcall code))        ;; execute the compiled form
  57.          (if print 
  58.              (progn
  59.                 (print return-value)
  60.                 (file-flush)))))
  61.     
  62. (defvar *asm* nil)
  63. (defvar *lex-counter* 0)
  64. (defvar *references* nil)
  65. (defvar *function-name* nil)
  66. (defvar *function-entry-label* nil)
  67. (defvar *cleanup-forms-stack* nil)
  68. (defvar *lambda-list* nil)
  69. (defvar *arg-count* 0)
  70. (defvar *last-call-was-values* nil)
  71. (defvar *environment* nil)
  72. (defvar *embedded-lambdas* nil)
  73. (defvar *lambda-special-vars* nil)
  74.  
  75. ;;
  76. ;;    The cleanup forms stack needs to be maintained for use in non-local
  77. ;;    lexically scoped exit situations. Specifically, GO with a target outside
  78. ;;    the current construct, and RETURN-FROM when exiting an external construct.
  79. ;;    Note that THROW targets are dynamic, not lexical, and therefore cannot
  80. ;;    be handled at compile time. They are handled via a different mechanism, a
  81. ;    run-time stack. Lexically scoped exits are better handled at compile time,
  82. ;;    both for efficiency (a big concern, because GO is the primary iteration 
  83. ;;    facility) and because the lexical scoping is currently only known at
  84. ;;    compile-time. In other words, a run-time lexical environment is not maintained
  85. ;;    for compiled code, and for efficiency reasons it would be better not to have
  86. ;;    to.
  87. ;;
  88. ;;    Entries on the cleanup forms stack include:
  89. ;;
  90. ;;    (BLOCK block-name block-exit-label)
  91. ;;    (TAGBODY (local-tag-1 . local-label-1) (local-tag-2 . local-label-2) ...)
  92. ;;    (LET (local-var-1 . index1) (local-var-2 . index2) ...)
  93. ;;        (the LET form is used by both LET *and* LET* forms)
  94. ;;    (CATCH catch-tag)
  95. ;;    (UNWIND-PROTECT <compiled code to be included>)
  96. ;; 
  97.  
  98. (defconstant *lambda-list-keywords* 
  99.         '(    &optional 
  100.             &rest 
  101.             &key 
  102.             &aux 
  103.             &allow-other-keys
  104.             &whole
  105.             &body ))
  106.  
  107. ;; the following aren't allowed in lambda function declarations
  108. ;; (only in macros, which will be expanded before we see them)
  109. (defconstant *unsupported-lambda-list-keywords* 
  110.         '(  &allow-other-keys
  111.             &whole
  112.             &body ))
  113.  
  114. ;;
  115. ;;    Set up square braces as assembly delimiters for this module
  116. ;;    This helps to clearly distinguish the generated code from the
  117. ;;    surrounding stuff.
  118. ;;
  119. (defun push-assembly-instructions (&rest instructions)
  120.     (dolist (x instructions)
  121.         (push x *asm*)))
  122. (defun assembly-start (stream char)
  123.     (cons 'push-assembly-instructions (read-delimited-list #\] stream)))
  124. (defun assembly-end (stream char) nil)
  125. (set-macro-character #\[ #'assembly-start)
  126. (set-macro-character #\] #'assembly-end)
  127. (defun push-cleanup (x) (push x *cleanup-forms-stack*))
  128. (defun pop-cleanup () (pop *cleanup-forms-stack*))
  129.  
  130. ;;    We use the following registers:
  131. ;;    A0, D0 : scratch registers. D0 ultimately returns the value.
  132. ;;    D3 : stores last returned value
  133. ;;    A2 : used as local index for function call
  134. ;;    A3 : points to lexical storage for the function
  135. ;;    A4 : points to function's environment (variables with indefinite extent)
  136. ;;    A6 : links previous stack frame
  137. ;;    A7 : stack pointer
  138. ;;    A5 : global variables
  139. ;;    
  140. ;;    We do not need to save A5, A6 or A7
  141. ;;    We also don't need to save scratch register D0.
  142. ;;    We *do* need to save A0, A2, A3 and D3.
  143. ;;
  144.             
  145. ;;
  146. ;;    compile-top-level-form (form &optional (assemble t))
  147. ;;    Given an arbitrary lisp form, returns a compiled function 
  148. ;;    equivalent to it.
  149. ;;
  150. (defun compile-top-level-form (form)
  151.     (let* (
  152.            ;; Establish local bindings of these special variables
  153.            ;; so that this function can be entered recursively.
  154.            ;;
  155.            (*asm* nil)
  156.            (*lex-counter* 0)
  157.            (*references* nil)
  158.            (*function-entry-label* (gensym))
  159.            (*last-call-was-values* nil)
  160.            (*cleanup-forms-stack* nil)
  161.            (*environment* nil)
  162.            (*embedded-lambdas* (find-lambdas form)))    
  163.            
  164.         ;; emit code for function prolog
  165. ;;        [ `(link a6 ,(- (* numargs 4))) ]     ;; this is added at end
  166.         (emit-prolog)
  167.                 
  168.         ;; compile the form
  169.         (compile-form form)
  170.  
  171.         ;; make sure bogus multiple values don't get returned
  172.         (unless *last-call-was-values* (kill-multiple-values))
  173.  
  174.         (emit-epilog)        
  175.         
  176.         ;; if we don't want to assemble it, exit here
  177.         (if *assemble-code* 
  178.             (return (assemble *asm* *references* nil))            
  179.             (return *asm*))))
  180.  
  181.  
  182. ;;---------------------------------------------------
  183. ;;
  184. ;;    compile-lambda (lambda)
  185. ;;    Given a lambda expression, returns a compiled function.
  186. ;;
  187. (defun compile-lambda (lambda func-name)
  188.     (check-lambda lambda)            ;; make sure we can compile it    
  189.     (let* ((*asm* nil)
  190.            (*references* nil)
  191.            (*function-name* func-name)
  192.            (*function-entry-label* (gensym))
  193.            (*cleanup-forms-stack* nil)
  194.            (*lambda-list* (cadr lambda))
  195.            (*last-call-was-values* nil)
  196.            (*environment* *environment*)    ;; inherit from enclosing expression
  197.            (*embedded-lambdas* (find-lambdas (cdr lambda)))    
  198.            (*arg-count* 0)
  199.            (*lex-counter* 0)
  200.            (*lambda-special-vars* nil)
  201.             
  202.            (forms (cddr lambda))
  203.            (new-vars (collect-new-vars *lambda-list*))
  204.            (aux-args (aux-arguments *lambda-list*)))
  205.  
  206.         (add-lexical-variables 
  207.             (remove-if #'special-variable-p new-vars :key #'car))
  208.  
  209.         (emit-prolog)
  210.         (compile-lambda-args)
  211.         (create-runtime-bindings)    ;; create necessary heap bindings
  212.         
  213.         ;; handle aux variables by just adding an implicit let* form
  214.         (if aux-args
  215.             (setf forms `((let* ,aux-args ,@forms))))
  216.             
  217.         (compile-nil)        ;; store NIL as default return value
  218.                 
  219.  
  220.         (if *lambda-special-vars*
  221.             (compile-unwind-protect-form 
  222.                 `(unwind-protect 
  223.                     (block ,func-name ,@forms)
  224.                     ($pop-special-bindings ',*lambda-special-vars*)))
  225.  
  226.             ;; else execute the forms directly
  227.             ;; compile the forms as a block
  228.             (compile-block-form `(block ,func-name ,@forms)))
  229.  
  230.         ;; make sure bogus multiple values don't get returned
  231.         (unless *last-call-was-values* (kill-multiple-values))
  232.  
  233.         (emit-epilog)
  234.         (pop-cleanup)        
  235.         (if *assemble-code* 
  236.             (return (assemble *asm* *references* nil))            
  237.             (return *asm*))))
  238.  
  239.  
  240. (defun compile-lambda-args ()
  241.     (compile-lambda-required-args)
  242.     (compile-lambda-optional-args)
  243.     (compile-lambda-rest-args)        
  244.     (check-no-more-args)
  245.     (compile-lambda-key-args))
  246.     
  247.  
  248. (defun collect-new-vars (lambda-list)
  249.     (let ((new-vars nil)(supplied_p_vars nil))
  250.         (dolist (n lambda-list)                    ;; add lexical vars
  251.             (if (not (member n *lambda-list-keywords*))
  252.                 (progn
  253.                     (if (consp n)
  254.                         (progn
  255.                             (if (>= (length n) 3)        ;; get supplied_p symbols
  256.                                 (push (caddr n) supplied_p_vars))
  257.                             (push (cons (car n) *lex-counter*) new-vars))
  258.                         (push (cons n *lex-counter*) new-vars))
  259.                     (incf *lex-counter*))))
  260.         (dolist (n supplied_p_vars)
  261.             (push (cons n *lex-counter*) new-vars)    ;; these need to go on the end
  262.             (incf *lex-counter*))
  263.         (nreverse new-vars)))                        
  264.  
  265.  
  266. ;; emit code for start of function            
  267. (defun emit-prolog ()
  268.     [ 
  269.         `(movem.l    a0 a2 a3 a4 d3 (-a7)) 
  270.     ]
  271.  
  272.     (if (or *embedded-lambdas* *environment*)
  273.     [
  274.         `(bsr 2)                        ; push current pc on stack
  275.         `(move.l (a7+) a4)                ; a4 = pc
  276.         `(move.l (a4 -16) a4)            ; a4 = pointer to environment (just before code)
  277.         
  278.     ])
  279.     
  280.     [
  281.         `(movea.l (a6 8) a2)            ; a2 = a6 + 8 = parameter block
  282.         `(lea (a7 20) a3)                ; a3 = pointer to local arguments
  283.                                         ; the offset to a7 should be 4 * number of
  284.                                         ; registers saved!
  285.     ])
  286.  
  287.  
  288. ;; emit code for end of function            
  289. (defun emit-epilog ()
  290.     [
  291.         `(move.l d3 d0)
  292.         `(movem.l (a6 ,(- -20 (* *lex-counter* 4))) a0 a2 a3 a4 d3)
  293.         `(unlk a6)                        ; unlink frame pointer
  294.         `(rts)                            ; d0 already contains return value
  295.     ]
  296.     
  297.     (setq *asm* (nreverse *asm*))
  298.  
  299.     ;; These last instructions get pushed onto the beginning
  300.     ;; of the (now-reversed) instructions. Therefore they are reversed
  301.     ;; here to come out in the right order.
  302.     [
  303.         `(link a6 ,(- (* *lex-counter* 4)))
  304.         *function-entry-label*
  305.     ]    
  306. )
  307.  
  308.  
  309. ;; Make sure there are no more arguments.
  310. (defun check-no-more-args ()
  311.     (if (not (or (rest-arguments *lambda-list*) (key-arguments *lambda-list*)))
  312.         [
  313.             `(move.l (a2+) (-a7))                ; get argument
  314.             `(jsr #'common-lisp::%checkNull)     ; signal error if extra argument
  315.             `(lea (a7 4) a7)                      ; cleanup stack
  316.         ]))
  317.  
  318. ;;
  319. ;;    compile-lambda-required-args
  320. ;;    Generates code to initialize required argumensts.
  321. ;;
  322. (defun compile-lambda-required-args ()
  323.     (dolist (sym (required-arguments *lambda-list*))
  324.         [
  325.             `(move.l (a2+) (-a7))            ; get argument
  326.             `(jsr #'common-lisp::%checkObj) ; signal error if argument missing
  327.             `(lea (a7 4) a7)                  ; cleanup stack
  328.             `(move.l d0 (a3 ,(* *arg-count* 4)))
  329.         ]
  330.         
  331.         (if (special-variable-p sym)
  332.             (progn 
  333.                 (push sym *lambda-special-vars*)
  334.                 [
  335.                     `(move.l 0 (-a7))
  336.                     `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  337.                     `(move.l ',sym (-a7))
  338.                     `(move.l a7 (-a7))
  339.                     `(jsr #'common-lisp::$push-special-bindings)
  340.                     `(lea (a7 16) a7)
  341.                 ]))
  342.  
  343.         (incf *arg-count*)))
  344.  
  345.  
  346. ;;
  347. ;;    compile-lambda-optional-args
  348. ;;    Generates code to initialize optional argumensts.
  349. ;;
  350. (defun compile-lambda-optional-args ()
  351.     (dolist (sym (optional-arguments *lambda-list*))
  352.         ;; initialize optional variable
  353.         (let ((else-label (gensym)) 
  354.                 (end-label (gensym)))
  355.             [
  356.                 `(tst.l (a2))                ;; is there an argument
  357.                 `(beq ,else-label)
  358.             ]
  359.             (if (and (consp sym) (>= (length sym) 3))
  360.                 (compile-form `(setq ,(caddr sym) t)))    ;; set supplied_p
  361.             [ 
  362.                 `(move.l (a2+) (a3 ,(* *arg-count* 4)))
  363.                 `(bra ,end-label)
  364.                 else-label
  365.             ]
  366.                 
  367.             ;; else do default initialization
  368.  
  369.             (if (and (consp sym) (>= (length sym) 3))
  370.                 (compile-form `(setq ,(caddr sym) nil)))    ;; set supplied_p
  371.  
  372.             (if (and (consp sym) (cdr sym))
  373.                 (progn
  374.                     [
  375.                         `(movem.l    a2 a3 d0 (-a7))
  376.                     ]
  377.                     (compile-form (cadr sym))
  378.                     [
  379.                         `(movem.l (a7+) a2 a3 d0)
  380.                         `(move.l d3 (a3 ,(* *arg-count* 4)))
  381.                     ])
  382.                 ;; else
  383.                 [
  384.                     `(move.l 'nil (a3 ,(* *arg-count* 4)))
  385.                 ])
  386.             [
  387.                 end-label
  388.             ])
  389.  
  390.         (if (special-variable-p sym)
  391.             (progn 
  392.                 (push sym *lambda-special-vars*)
  393.                 [
  394.                     `(move.l 0 (-a7))
  395.                     `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  396.                     `(move.l ',sym (-a7))
  397.                     `(move.l a7 (-a7))
  398.                     `(jsr #'common-lisp::$push-special-bindings)
  399.                     `(lea (a7 16) a7)
  400.                 ]))
  401.             
  402.         (incf *arg-count*)))
  403.  
  404.  
  405. ;;
  406. ;;    compile-lambda-rest-args
  407. ;;    Generates code to initialize rest arguments.
  408. ;;    We allow more than one.
  409. ;;
  410. (defun compile-lambda-rest-args ()
  411.     (let* ((rest-args (rest-arguments *lambda-list*)))
  412.         (if rest-args
  413.             [
  414.                 `(move.l a2 (-a7))
  415.                 `(jsr #'list)
  416.                 `(lea (a7 4) a7)
  417.             ])
  418.         (dolist (sym rest-args)
  419.             [
  420.                 `(move.l d0 (a3 ,(* *arg-count* 4)))
  421.             ]
  422.         
  423.             (if (special-variable-p sym)
  424.                 (progn 
  425.                     (push sym *lambda-special-vars*)
  426.                     [
  427.                         `(move.l 0 (-a7))
  428.                         `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  429.                         `(move.l ',sym (-a7))
  430.                         `(move.l a7 (-a7))
  431.                         `(jsr #'common-lisp::$push-special-bindings)
  432.                         `(lea (a7 16) a7)
  433.                     ]))
  434.  
  435.             (incf *arg-count*))))
  436.  
  437.  
  438. ;;
  439. ;;    compile-lambda-key-args
  440. ;;    Generates code to initialize key argumensts.
  441. ;;
  442. (defun compile-lambda-key-args ()
  443.     (dolist (n (key-arguments *lambda-list*))
  444.         (let* ((loop-label (gensym))
  445.                (exit-label (gensym))
  446.                (not-found-label (gensym))
  447.                lex-var 
  448.                default-init 
  449.                key-symbol)
  450.                         
  451.             (if (consp n)
  452.                 (setq lex-var (car n))
  453.                 (setq lex-var n))
  454.                             
  455.             (if (and (consp n) (cdr n))
  456.                 (setq default-init (cadr n))
  457.                 (setq default-init nil))                        
  458.                     
  459.             (setq key-symbol 
  460.                 (intern (symbol-name lex-var) (find-package :keyword)))
  461.                         
  462.             [
  463.                 `(move.l a2 a0)            ; a0 = current argument location
  464.                 `(move.l ',key-symbol d0)
  465.                 loop-label
  466.                 `(tst.l (a0))            ; make sure there are more arguments
  467.                 `(beq ,not-found-label)
  468.                 `(cmp.l (a0+) d0)
  469.                 `(bne ,loop-label)
  470.                 `(move.l (a0) (-a7))    ; make sure there is another argument
  471.                 `(jsr #'common-lisp::%checkObj)
  472.                 `(lea (a7 4) a7)          ; cleanup stack
  473.                 `(move.l d0 (a3 ,(* *arg-count* 4)))
  474.                 `(bra ,exit-label)
  475.                 not-found-label    
  476.             ]
  477.             (compile-form default-init)
  478.             [
  479.                 `(move.l d3 (a3 ,(* *arg-count* 4)))
  480.                 exit-label
  481.             ]
  482.  
  483.             (if (special-variable-p n)
  484.                 (progn 
  485.                     (push n *lambda-special-vars*)
  486.                     [
  487.                         `(move.l 0 (-a7))
  488.                         `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  489.                         `(move.l ',n (-a7))
  490.                         `(move.l a7 (-a7))
  491.                         `(jsr #'common-lisp::$push-special-bindings)
  492.                         `(lea (a7 16) a7)
  493.                     ]))
  494.  
  495.             (incf *arg-count*))))
  496.  
  497.  
  498. ;;---------------------------------------------------
  499.  
  500. (defun compile-form (form)
  501.     (setq *last-call-was-values* nil)
  502.     (cond 
  503.         ((null form) (compile-nil))
  504.         ((symbolp form) (compile-symbol form))
  505.         ((not (consp form))    (compile-literal-form form))
  506.         (t (compile-list-form form))))
  507.  
  508.  
  509. (defun compile-list-form (form)
  510.     (let ((firstobj (car form)))
  511.         (cond 
  512.             ((consp firstobj) (compile-explicit-lambda form))
  513.             ((not (symbolp firstobj))
  514.                 (error "Can't compile form--does not begin with a symbol"))
  515.             ((macro-function firstobj) (compile-form (macroexpand form)))
  516.             ((special-form-p firstobj) (compile-special-form form))
  517.             ((eq firstobj 'common-lisp::values) (compile-values-form form))
  518.             (t (compile-function-form form)))))
  519.  
  520.  
  521. (defun compile-special-form (form)
  522.     (case (car form)
  523.         (quote                     (compile-quote-form form)) 
  524.         (if                     (compile-if-form form))
  525.         (tagbody                 (compile-tagbody-form form))
  526.         (go                     (compile-go-tag form))
  527.         (setq                     (compile-setq-form form))
  528.         (block                     (compile-block-form form))
  529.         (return-from             (compile-return-from-form form))
  530.         (progn                     (compile-progn-form form))
  531.         (let                     (compile-let-form form))
  532.         (let*                     (compile-let*-form form))
  533.         (function                (compile-function-special-form form))
  534.         (catch                    (compile-catch-form form))
  535.         (throw                    (compile-throw-form form))
  536.         (unwind-protect         (compile-unwind-protect-form form))
  537.         (multiple-value-call     (compile-multiple-value-call-form form))
  538.         (declare                nil)    ;; ignore declarations for now
  539.         (otherwise                 (error "Special form not supported: ~A~%" (car form)))))
  540.  
  541.  
  542. (defun compile-explicit-lambda (form)
  543.     (let (func)
  544.         (if (not (eq 'lambda (caar form)))
  545.             (error "The first element of the expression: ~A is a list but it
  546.                     isn't a lambda expression~%" (car form)))
  547.         (setq func (compile-lambda (car form) nil))
  548.         [
  549.             `(move.l ',func d3)
  550.         ]
  551.         (export-environment)
  552.         (setq form (cons 'funcall (cons func (cdr form))))
  553.         (compile-form form)))
  554.  
  555.  
  556. (defun compile-symbol (sym)
  557.     (let ((temp (find-lex sym)))        ; check for lexical variable
  558.         (if temp
  559.             (if (integerp (cdr temp))
  560.                 [
  561.                     `(move.l (a3 ,(* (cdr temp) 4)) d3)
  562.                 ]
  563.                 ;; else
  564.                 [
  565.                     `(move.l (a3 ,(* (cadr temp) 4)) a0)
  566.                     `($CDR a0 d3)
  567.                 ])
  568.         ;; else see if it is in the inherited environment
  569.             (if (member sym *environment*)
  570.                 [
  571.                     `(move.l 0 (-a7))
  572.                     `(move.l ',sym (-a7))
  573.                     `(move.l a4 (-a7))
  574.                     `(move.l a7 (-a7))
  575.                     `(jsr #'%environment-get-value)
  576.                     `(lea (a7 16) a7)
  577.                     `(move.l d0 d3)
  578.                 ]
  579.             ;; else assume special variable
  580.                 (compile-function-form `(symbol-value ',sym))))))
  581.                 
  582.  
  583. (defun compile-if-form (form)
  584.     (let ((else-label (gensym)) 
  585.           (end-label (gensym))
  586.           (test-form (cadr form))
  587.           (then-form (caddr form))
  588.           (else-form (cdddr form)))
  589.  
  590.         (compile-form test-form)
  591.         [
  592.             `(cmp.l 'nil d3)
  593.             `(beq ,else-label)
  594.         ]
  595.         (compile-form then-form)
  596.         (if (consp else-form)
  597.             [
  598.                 `(bra ,end-label)
  599.             ])
  600.         [
  601.             else-label
  602.         ]
  603.         (if (consp else-form)
  604.             (compile-form (car else-form)))
  605.         [
  606.             end-label
  607.         ]))
  608.  
  609.  
  610. (defun compile-tagbody-form (form)
  611.     (let ((tags nil))
  612.         ;; go through list once collecting tags
  613.         (dolist (n (cdr form))
  614.             (if (or (integerp n) (symbolp n))
  615.                 (push (cons n (gensym)) tags)))
  616.         
  617.         (push-cleanup (cons 'tagbody tags))
  618.  
  619.         (dolist (n (cdr form))
  620.             (if (or (integerp n) (symbolp n))
  621.                 (push (cdr (assoc n tags)) *asm*)
  622.                 ;; else it is a form to be evaluated
  623.                 (compile-form n)))
  624.  
  625.         (pop-cleanup)))
  626.             
  627. (defun compile-go-tag (form)
  628.     (let ((tag (cadr form)))
  629.         (if (not (or (integerp tag) (symbolp tag)))
  630.             (error "Invalid go tag encountered"))
  631.         (if (not (find-go-tag tag))            ;; if the tag is not already defined 
  632.             (error "Tag not defined in this scope"))
  633.  
  634.         ;; peel off cleanup stack
  635.         (let ((dest (find-go-tag-tagbody tag)))
  636.             (dolist (f *cleanup-forms-stack*)
  637.                 (if (eq f dest) (return))        ;; returns from the dolist block
  638.                 (case (car f)
  639.                     (unwind-protect  
  640.                         ;; include cleanup code
  641.                         (let ((cleanup-code (cdr f)))
  642.                             (dolist (n cleanup-code)
  643.                                 (push n *asm*))))
  644.                     (catch
  645.                         ;; remove dynamic catch tag
  646.                         [
  647.                             `(jsr #'common-lisp::%popCatcher)    ;; restore result
  648.                         ]))))
  649.                     
  650.         [
  651.             `(bra ,(cdr (find-go-tag tag)))
  652.         ])) 
  653.  
  654. (defun compile-setq-form (form)
  655.     (do ((f (cdr form) (cddr f)) var val temp)
  656.         ((endp f))
  657.         (setq var (car f))
  658.         (setq val (cadr f))
  659.         (setf temp (find-lex var))    ; check for lexical variable
  660.         (if temp
  661.             (progn
  662.                 (compile-form val)
  663.                 (if (integerp (cdr temp))
  664.                     [
  665.                         `(move.l d3 (a3 ,(* (cdr temp) 4)))
  666.                     ]
  667.                 ;; else
  668.                     [
  669.                         `(move.l (a3 ,(* (cadr temp) 4)) a0)
  670.                         `($SETCDR a0 d3)
  671.                     ]))
  672.         ;; else look in the inherited environment
  673.             (if (member var *environment*)
  674.                 (progn
  675.                     (compile-form val)
  676.                     [
  677.                         `(move.l 0 (-a7))
  678.                         `(move.l d3 (-a7))
  679.                         `(move.l ',var (-a7))
  680.                         `(move.l a4 (-a7))
  681.                         `(move.l a7 (-a7))
  682.                         `(jsr #'%environment-set-value)
  683.                         `(lea (a7 20) a7)
  684.                         `(move.l d0 d3)
  685.                     ])
  686.             ;; else call set function
  687.                 (compile-form `(set ',var ,val))))))
  688.  
  689.  
  690. (defun compile-quote-form (form)
  691.     (compile-literal-form (cadr form)))
  692.  
  693. (defun compile-block-form (form)
  694.     (let ((block-name (cadr form)) 
  695.           (block-forms (cddr form)) 
  696.           (exit-label (gensym)))
  697.         (push-cleanup (list 'block block-name exit-label))
  698.  
  699.         (dolist (f block-forms)
  700.             (compile-form f))
  701.  
  702.         [
  703.             exit-label
  704.         ]
  705.         (pop-cleanup)))
  706.  
  707. (defun compile-return-from-form (form)
  708.     (let ((block-name (cadr form))
  709.           (retval nil)
  710.           temp)
  711.         (if (consp (cddr form))
  712.             (setq retval (caddr form)))
  713.         (compile-form retval)
  714.         (if (null block-name)
  715.             (setq temp (find-any-block))
  716.             ;; else
  717.             (setq temp (find-block block-name)))
  718.         (unless temp (error "Block label not found"))
  719.  
  720.         ;; peel off cleanup stack
  721.         (let ((dest temp))
  722.             (dolist (f *cleanup-forms-stack*)
  723.                 (if (eq f dest) (return))        ;; returns from the dolist block
  724.                 (case (car f)
  725.                     (unwind-protect  
  726.                         ;; include cleanup code
  727.                         (let ((cleanup-code (cdr f)))
  728.                             (dolist (n cleanup-code)
  729.                                 (push n *asm*))))
  730.                     (catch
  731.                         ;; remove dynamic catch tag
  732.                         [
  733.                             `(jsr #'common-lisp::%popCatcher)    ;; restore result
  734.                         ]))))
  735.  
  736.         [    
  737.             `(bra ,(caddr temp))
  738.         ]))    
  739.  
  740. (defun compile-progn-form (form)
  741.     (let ((progn-forms (cdr form))) 
  742.         (dolist (f progn-forms)
  743.             (compile-form f))))
  744.  
  745. (defun compile-let-form (form)
  746.     (let* ((local-vars (cadr form)) 
  747.            (let-forms (cddr form)) 
  748.            (new-vars nil)
  749.            (special-vars nil)
  750.            sym)
  751.  
  752.         ;; go through variable list evaluating values and assigning to temporary
  753.         ;; space on the stack
  754.         (dolist (f local-vars)
  755.             (unless (or (consp f) (symbolp f)) 
  756.                 (error "Invalid 'let' variable"))
  757.             (if (or (symbolp f) (not (consp (cdr f))))
  758.                 [
  759.                     `(move.l 'nil (a3 ,(* *lex-counter* 4)))
  760.                 ]
  761.                 ;; else
  762.                 (progn
  763.                     (compile-form (cadr f))
  764.                     [
  765.                         `(move.l d3 (a3 ,(* *lex-counter* 4)))
  766.                     ]))
  767.  
  768.             ;; add the symbol to the list of new symbols
  769.             (if (consp f) 
  770.                 (setq sym (car f)) 
  771.                 (setq sym f)) 
  772.                 
  773.             (if (special-variable-p sym)
  774.                 (progn 
  775.                     (if (null special-vars)     ;; if first one
  776.                         [
  777.                             `(move.l 0 (-a7))
  778.                         ])
  779.                     (push sym special-vars)
  780.                     [
  781.                         `(move.l (a3 ,(* *lex-counter* 4)) (-a7))
  782.                         `(move.l ',sym (-a7))
  783.                     ])
  784.                 ;; else
  785.                 (push (cons sym *lex-counter*) new-vars))
  786.  
  787.             (incf *lex-counter*))
  788.  
  789.         ;; add the new variables to the lexical environment
  790.         (add-lexical-variables new-vars)
  791.         (create-runtime-bindings)
  792.         
  793.         ;; if any special variables are present, add those bindings now
  794.         (if special-vars
  795.             (progn
  796.                 [
  797.                     `(move.l a7 (-a7))
  798.                     `(jsr #'common-lisp::$push-special-bindings)
  799.                     `(lea (a7 ,(* 8 (1+ (length special-vars)))) a7)
  800.                 ]
  801.                 (compile-unwind-protect-form 
  802.                     `(unwind-protect 
  803.                         (progn ,@let-forms)
  804.                         ($pop-special-bindings ',special-vars))))
  805.  
  806.             ;; else execute the forms directly
  807.             (dolist (f let-forms)
  808.                 (compile-form f)))
  809.         
  810.         ;; restore old lexical environment
  811.         (pop-cleanup)))
  812.  
  813. (defun compile-let*-form (form)
  814.     (let* ((local-vars (cadr form)) 
  815.            (let-forms (cddr form))
  816.            (special-vars nil)
  817.            sym
  818.            (lex-var-count 0))
  819.  
  820.         ;; go through variable list evaluating values and assigning to temporary
  821.         ;; space on the stack
  822.         (dolist (f local-vars)
  823.             (unless (or (consp f) (symbolp f)) 
  824.                 (error "Invalid 'let' variable: ~A~%" f))
  825.             (if (or (symbolp f) (not (consp (cdr f))))
  826.                 [
  827.                     `(move.l 'nil (a3 ,(* *lex-counter* 4)))
  828.                 ]
  829.                 ;; else
  830.                 (progn
  831.                     (compile-form (cadr f))
  832.                     [
  833.                         `(move.l d3 (a3 ,(* *lex-counter* 4)))
  834.                     ]))
  835.  
  836.             ;; add the symbol to the list of new symbols
  837.             (if (consp f) 
  838.                 (setq sym (car f)) 
  839.                 (setq sym f)) 
  840.     
  841.             (if (special-variable-p sym)
  842.                 (progn 
  843.                     (push sym special-vars)
  844.                     [
  845.                         `(move.l 0 (-a7))
  846.                         `(move.l (a3 ,(* *lex-counter* 4)) (-a7))
  847.                         `(move.l ',sym (-a7))
  848.                         `(move.l a7 (-a7))
  849.                         `(jsr #'common-lisp::$push-special-bindings)
  850.                         `(lea (a7 16) a7)
  851.                     ])
  852.                 ;; else
  853.                 (progn
  854.                     (add-lexical-variables (list (cons sym *lex-counter*)))
  855.                     (incf lex-var-count)))
  856.  
  857.             (incf *lex-counter*))
  858.  
  859.         (create-runtime-bindings)    
  860.         
  861.         ;; if any special variables are present, add those bindings now
  862.         (if special-vars
  863.             (compile-unwind-protect-form 
  864.                 `(unwind-protect 
  865.                     (progn ,@let-forms)
  866.                     ($pop-special-bindings ',special-vars)))
  867.  
  868.             ;; else execute the forms directly
  869.             (dolist (f let-forms)
  870.                 (compile-form f)))
  871.         
  872.         ;; restore old lexical environment
  873.         (dotimes (i lex-var-count)
  874.             (pop-cleanup))))
  875.  
  876.  
  877. (defun compile-function-special-form (form)
  878.     (let ((func-form (cadr form)))
  879.         
  880.         ;; I don't think this will occur, but just in case, we can't
  881.         ;; keep a reference to an anonymous function object.
  882.         (if (functionp func-form)
  883.             (error "Can't compile expression with anonymous function: ~A~%" form))
  884.  
  885.         ;; if a compiled lambda expression
  886.         (if (and (consp func-form) (eq (car func-form) 'lambda))
  887.             (let ((name nil)
  888.                   (first-form (third func-form)))
  889.                 (if (and (consp first-form) (eq (first first-form) 'block))
  890.                     (setq name (second (third func-form))))
  891.  
  892.                 ;; create a new compiled function
  893.                 (setq func-form (compile-lambda func-form name))     
  894.                 [
  895.                     `(move.l 0 (-a7))
  896.                     `(move.l ',func-form (-a7))
  897.                     `(move.l a7 (-a7))
  898.                     `(jsr #'%copy-compiled-function)
  899.                     `(lea (a7 12) a7)
  900.                     `(move.l d0 d3)
  901.                 ]
  902.                 (export-environment)
  903.                 (return)))
  904.                 
  905.         (unless (symbolp func-form)
  906.             (error "function special form: ~%Expected a symbol: ~A~%" func-form))
  907.             
  908.         (compile-form `(symbol-function ',func-form)))) 
  909.  
  910. (defun compile-catch-form (form)
  911.     (let ((catch-tag (cadr form)) 
  912.           (catch-forms (cddr form)) 
  913.           (exit-label (gensym)))
  914.  
  915.         (push-cleanup (list 'CATCH catch-tag))
  916.         
  917.         ;; evaluate the tag
  918.         (compile-form catch-tag)
  919.         
  920.         ;; make room for jmp-buf on stack (12 * 4 bytes)
  921.         [
  922.             `(lea (a7 -48) a7)
  923.  
  924.         ;; pushCatcher(tag, jmp_buf)
  925.             `(move.l a7 (-a7))            ;; push jmp_buf
  926.             `(move.l d3 (-a7))            ;; push tag
  927.             `(jsr #'common-lisp::%pushCatcher)
  928.             `(lea (a7 8) a7)            ;; cleanup stack
  929.  
  930.         ;; setjmp(jmp_buf)
  931.             `(move.l a7 (-a7))            ;; push jmp_buf
  932.             `(jsr #'common-lisp::%setjmp)
  933.             `(lea (a7 4) a7)
  934.         
  935.         ;; if d0 != 0, we caught an exception
  936.             `(move.l d0 d3)
  937.             `(tst.l d0)
  938.             `(bne ,exit-label) 
  939.             `(move.l 'nil d3)
  940.         ]
  941.         
  942.         (dolist (f catch-forms)
  943.             (compile-form f))
  944.  
  945.         [
  946.             exit-label
  947.         ]
  948.         
  949.         (pop-cleanup)
  950.         
  951.         ;; popCatcher()
  952.         [
  953.             `(lea (a7 48) a7)        ;; cleanup jmp_buf
  954.             `(jsr #'common-lisp::%popCatcher)
  955.         ]))
  956.         
  957. (defun compile-throw-form (form)
  958.     (let ((throw-tag (cadr form)) 
  959.           (throw-form (caddr form))) 
  960.  
  961.         ;; evaluate the form
  962.         (compile-form throw-form)
  963.         [
  964.             `(move.l d3 (-a7))
  965.         ]
  966.         
  967.         ;; evaluate the tag
  968.         (compile-form throw-tag)
  969.         [
  970.             `(move.l d3 (-a7))            
  971.             `(jsr #'%throwException)    ;; call throw handler
  972.         ]))
  973.  
  974. (defun compile-unwind-protect-form (form)
  975.     (let ((protected-form (cadr form))
  976.           (cleanup-forms (cddr form)) 
  977.           (label1 (gensym))
  978.           (label2 (gensym)))
  979.         
  980.         ;; make room for jmp-buf on stack (12 * 4 bytes)
  981.         [
  982.             `(lea (a7 -48) a7)
  983.  
  984.             ;; pushCatcher(tag, jmp_buf)
  985.             `(move.l a7 (-a7))                ;; push jmp_buf
  986.             `(moveq 0 d0)
  987.             `(move.l d0 (-a7))                ;; push tag
  988.             `(jsr #'common-lisp::%pushCatcher)
  989.             `(lea (a7 8) a7)                ;; cleanup stack
  990.  
  991.             ;; setjmp(jmp_buf)
  992.             `(move.l a7 (-a7))                ;; push jmp_buf
  993.             `(jsr #'common-lisp::%setjmp)
  994.             `(lea (a7 4) a7)
  995.         
  996.             ;; if d0 != 0, we caught an exception
  997.             `(move.l d0 d3)
  998.             `(move.l d0 (-a7))                ;; save result on stack
  999.             `(tst.l d0)
  1000.             `(bne ,label1)
  1001.         ]
  1002.         
  1003.         ;; generate code for cleanup forms
  1004.         (let ((*asm* nil))
  1005.             [
  1006.                 `(move.l d3 (-a7))            ;; store result
  1007.                 `(move.l common-lisp::%multiple-values-address a0)
  1008.                 `(move.l (a0) (-a7))
  1009.                 `(jsr #'common-lisp::%popCatcher)
  1010.             ]
  1011.             (dolist (f cleanup-forms)
  1012.                 (compile-form f))
  1013.             [
  1014.                 `(move.l common-lisp::%multiple-values-address a0)
  1015.                 `(move.l (a7+) (a0))
  1016.                 `(move.l (a7+) d3)            ;; retrieve result
  1017.             ]
  1018.             (setq *asm* (reverse *asm*))
  1019.             (push-cleanup (cons 'UNWIND-PROTECT *asm*))) 
  1020.         
  1021.         ;; compile protected form
  1022.         (compile-form protected-form)
  1023.  
  1024.         [
  1025.             label1
  1026.         ]
  1027.         
  1028.         ;; include cleanup code
  1029.         (let ((cleanup-code (cdr (pop-cleanup))))
  1030.             (dolist (n cleanup-code)
  1031.                 (push n *asm*)))
  1032.                 
  1033.         ;; retrieve exception result
  1034.         [
  1035.             `(move.l (a7+) a0)
  1036.             `(tst.l a0)
  1037.             `(beq ,label2)
  1038.  
  1039.             ;; continue thrown exception
  1040.             `(move.l a0 (-a7))
  1041.             `(jsr #'common-lisp::%continueException)
  1042.             label2
  1043.             `(lea (a7 48) a7)        ;; cleanup jmp_buf
  1044.         ]))
  1045.  
  1046. (defun compile-multiple-value-call-form (form)
  1047.     (let* ((func (cadr form))
  1048.            (forms (cddr form))
  1049.            (numforms (length forms))
  1050.            (stackframe (* 4 (1+ numforms)))
  1051.            (counter 0)
  1052.            temp)
  1053.         (compile-form func)
  1054.         [
  1055.             `(move.l d3 (-a7))                ; push function address on stack
  1056.             `(lea (a7 ,(- stackframe)) a7)
  1057.         ]
  1058.         (dolist (p forms)                    ; execute each form
  1059.             (compile-form p)
  1060.             [
  1061.                 `($IFELSE 
  1062.                     (
  1063.                         (tst.l (common-lisp::%multiple-values-address))
  1064.                     )
  1065.                     (
  1066.                         ;; if no multiple values, just list the single value
  1067.                         (move.l 0 (-a7))
  1068.                         (move.l 'nil (-a7))
  1069.                         (move.l d3 (-a7))
  1070.                         (move.l a7 (-a7))
  1071.                         (jsr #'cons)
  1072.                         (lea (a7 16) a7)
  1073.                         (move.l d0 d3)
  1074.                     )
  1075.                     (
  1076.                         ;; otherwise get the list of values
  1077.                         (move.l (common-lisp::%multiple-values-address) d3)
  1078.                     ))    
  1079.                         
  1080.                 `(move.l d3 (a7 ,(* counter 4)))
  1081.             ]
  1082.             (incf counter))
  1083.         
  1084.         ;; concatenate all the lists together and store in d3
  1085.         [
  1086.             `(clr.l (a7 ,(* counter 4)))
  1087.             `(move.l a7 (-a7))            ; pass address of params to function
  1088.             `(jsr #'append)
  1089.             `(move.l d0 d3)
  1090.             `(lea (a7 ,(+ 4 stackframe)) a7)            
  1091.         ]
  1092.  
  1093.         ;; now apply the passed function to the resulting value list
  1094.         [
  1095.             `(move.l (a7+) a0)            ; a0 = function address
  1096.             `(move.l 0 (-a7))
  1097.             `(move.l d3 (-a7))            ; argument list
  1098.             `(move.l a0 (-a7))            ; function
  1099.             `(move.l a7 (-a7))            ; pass address of params to function
  1100.             `(jsr #'apply)
  1101.             `(move.l d0 d3)
  1102.             `(lea (a7 16) a7)            
  1103.         ]))
  1104.  
  1105. (defun compile-function-form (form)
  1106.     (compile-function-call-form form))
  1107.     
  1108. (defun compile-values-form (form)
  1109.     (compile-function-call-form form)
  1110.     (setq *last-call-was-values* t))
  1111.     
  1112. (defun compile-function-call-form (form)
  1113.  
  1114.     ;; print warning message if function hasn't been defined yet
  1115.     (if (not (functionp (symbol-function (car form))))
  1116.         (format t "Warning: function ~A missing definition~%" (car form)))
  1117.  
  1118.     (let* ((numparams (1- (length form)))
  1119.            (stackframe (* 4 (1+ numparams)))
  1120.            (func (car form))
  1121.            (funcparams (cdr form))
  1122.            (counter 0)
  1123.            temp)
  1124.         [
  1125.             `(lea (a7 ,(- stackframe)) a7)
  1126.         ]
  1127.         (dolist (p funcparams)                ; get parameters for function call
  1128.             (setf temp (find-lex p))        ; check for lexical variable
  1129.             (if temp
  1130.                 (if (integerp (cdr temp))
  1131.                     [
  1132.                         `(move.l (a3 ,(* (cdr temp) 4)) (a7 ,(* counter 4)))
  1133.                     ]
  1134.                     ;; else
  1135.                     [
  1136.                         `(move.l (a3 ,(* (cadr temp) 4)) a0)
  1137.                         `($CDR a0 (a7 ,(* counter 4)))
  1138.                     ])
  1139.                 ;; else
  1140.                 (progn 
  1141.                     (compile-form p)    ; ignore multiple values in params
  1142.                     [
  1143.                         `(move.l d3 (a7 ,(* counter 4)))
  1144.                     ]))
  1145.             (incf counter))
  1146.         
  1147.         ;; clear the last position to zero
  1148.         [
  1149.             `(clr.l (a7 ,(* counter 4)))
  1150.             `(move.l a7 (-a7))                ; pass address of params to function
  1151.         ]
  1152.         
  1153.         ;; if it is a recursive call to this function, we need to handle it specially
  1154.         (if (eq func *function-name*)
  1155.             [
  1156.                 `(bsr ,*function-entry-label*)
  1157.             ]
  1158.         ;; else
  1159.             (progn
  1160.                 [
  1161.                     `(jsr #',func)
  1162.                 ]))
  1163.         
  1164.         [
  1165.             `(move.l d0 d3)    
  1166.             `(lea (a7 ,(+ 4 stackframe)) a7)     ;; clean up stack
  1167.         ])) 
  1168.  
  1169. (defun compile-integer (form)
  1170.     [
  1171.         `(move.l ,form (-a7))
  1172.         `(jsr #'common-lisp::%integerAtom)
  1173.         `(lea (a7 4) a7)
  1174.         `(move.l d0 d3)
  1175.     ])
  1176.  
  1177. (defun string-int-with-pad (string index)
  1178.     (if (>= index (length string))
  1179.         0
  1180.         (char-int (elt string index))))
  1181.     
  1182. (defun compile-string (string)
  1183.   (let* ((numchars (+ 1 (length string)))
  1184.           n
  1185.           temp
  1186.           (num-longs (truncate (+ 3 numchars) 4)))
  1187.  
  1188.     ;; allocate room for the string
  1189.     [
  1190.         `(lea (a7 ,(- (* num-longs 4))) a7)
  1191.         `(move.l a7 a0)
  1192.     ]
  1193.     (dotimes (i num-longs)
  1194.         (setq temp (* i 4))
  1195.  
  1196.         ;; gather four characters into a long
  1197.         (setq n
  1198.             (+
  1199.                 (* (string-int-with-pad string temp) #x1000000)
  1200.                 (* (string-int-with-pad string (+ temp 1)) #x10000)
  1201.                 (* (string-int-with-pad string (+ temp 2)) #x100)
  1202.                 (string-int-with-pad string (+ temp 3))))
  1203.         [
  1204.             `(move.l ,n (a0+))
  1205.         ])
  1206.         
  1207.     ;; now push the address of this string on the stack and create a string
  1208.     [
  1209.         `(move.l a7 (-a7))
  1210.         `(jsr #'common-lisp::%stringAtom)
  1211.         `(lea (a7 ,(+ 4 (* 4 num-longs))) a7)
  1212.         `(move.l d0 d3)
  1213.     ]))
  1214.  
  1215.  
  1216. ;; TDE:
  1217. ;; need to add support for bit-vectors, struct
  1218. (defun compile-literal-form (form)
  1219.     (cond
  1220.         ((symbolp form)        [ `(move.l ',form d3) ])            
  1221.         ((integerp form)     (compile-integer form))
  1222.         ((stringp form)        (compile-string form))
  1223.         ((characterp form)     (compile-character form))
  1224.         ((listp form)         (compile-quoted-list form))
  1225.         ((vectorp form)        (compile-vector form))
  1226.         ((floatp form)        (compile-float form))
  1227.         ((typep form 'ratio)(compile-ratio form))
  1228.         
  1229.         ;; we will have to code a direct reference to the object
  1230.         ;; This won't work if we use 'compile-file'.
  1231.         (t [ `(move.l ',form d3) ])))
  1232.             
  1233. (defun compile-character (form)
  1234.     [
  1235.         `(move.l ,(char-int form) (-a7))
  1236.         `(jsr #'common-lisp::%charAtom)
  1237.         `(lea (a7 4) a7)
  1238.         `(move.l d0 d3)
  1239.     ])
  1240.     
  1241. ;;
  1242. ;;    compile-quoted-list()
  1243. ;;    We catch and save the last form in case we are dealing with
  1244. ;;    a dotted list or dot pair.
  1245. ;;
  1246. (defun compile-quoted-list (form &aux (last-element (cdr (last form))))
  1247.     (setq form (reverse form))
  1248.     (let ((list-length (length form)))
  1249.         [
  1250.             `(move.l 0 (-a7))
  1251.         ]
  1252.         (compile-literal-form last-element)
  1253.         [
  1254.             `(move.l d3 (-a7))
  1255.         ]
  1256.         (dolist (f form)
  1257.             (compile-literal-form f)
  1258.             [
  1259.                 `(move.l d3 (-a7))
  1260.             ])
  1261.         [
  1262.             `(move.l a7 (-a7))
  1263.             `(jsr #'list*)
  1264.             `(lea (a7 ,(+ 12 (* list-length 4))) a7)
  1265.             `(move.l d0 d3)
  1266.         ]))
  1267.  
  1268. ;;
  1269. ;;    compile-vector()
  1270. ;;
  1271. (defun compile-vector (form)
  1272.     (setq form (reverse (concatenate 'list form)))
  1273.     (let ((list-length (length form)))
  1274.         [
  1275.             `(move.l 0 (-a7))
  1276.         ]
  1277.         (dolist (f form)
  1278.             (compile-literal-form f)
  1279.             [
  1280.                 `(move.l d3 (-a7))
  1281.             ])
  1282.         [
  1283.             `(move.l a7 (-a7))
  1284.             `(jsr #'vector)
  1285.             `(lea (a7 ,(+ 8 (* list-length 4))) a7)
  1286.             `(move.l d0 d3)
  1287.         ]))
  1288.  
  1289. ;; define these in order to get at the binary representation of a floating
  1290. ;; point number so that we can generate the machine code to build it.
  1291. ;; These functions don't check their type, so we get get the data.
  1292.  
  1293. (defasm car_ (x)
  1294. #{
  1295.     ($FUNC-BEGIN 0)
  1296.     (move.l (a0) a0)
  1297.     ($CAR a0)
  1298.     (move.l a0 (-a7))
  1299.     (jsr #'common-lisp::%integerAtom)
  1300.     (lea (a7 4) a7)
  1301.     ($RETURN d0)
  1302. })
  1303.  
  1304. (defasm cdr_ (x)
  1305. #{
  1306.     ($FUNC-BEGIN 0)
  1307.     (move.l (a0) a0)
  1308.     ($CDR a0)
  1309.     (move.l a0 (-a7))
  1310.     (jsr #'common-lisp::%integerAtom)
  1311.     (lea (a7 4) a7)
  1312.     ($RETURN d0)
  1313. })
  1314.  
  1315. ;;
  1316. ;;    compile-float()
  1317. ;;
  1318. (defun compile-float (form)
  1319.     [
  1320.         `(move.l ,(cdr_ form) (-a7))
  1321.         `(move.l ,(car_ form) (-a7))
  1322.         `(jsr #'common-lisp::%floatAtomFromLongs)
  1323.         `(lea (a7 8) a7)
  1324.         `(move.l d0 d3)
  1325.     ])
  1326.  
  1327. ;;
  1328. ;;    compile-ratio()
  1329. ;;
  1330. (defun compile-ratio (form)
  1331.     [
  1332.         `(move.l 0 (-a7))
  1333.     ]
  1334.     (compile-integer (denominator form))
  1335.     [
  1336.         `(move.l d3 (-a7))
  1337.     ]    
  1338.     (compile-integer (numerator form))
  1339.     [
  1340.         `(move.l d3 (-a7))
  1341.         `(move.l a7 (-a7))
  1342.         `(jsr #'/)
  1343.         `(lea (a7 16) a7)
  1344.         `(move.l d0 d3)
  1345.     ])
  1346.     
  1347.  
  1348. (defun check-lambda (lambda)
  1349.     (let ((lambda-list (cadr lambda)))
  1350.         (dolist (n lambda-list)
  1351.             (if (member n *unsupported-lambda-list-keywords*)
  1352.                 (error "Can't compile this lambda list keyword: ~A~%" n)))))
  1353.             
  1354.     
  1355. (defun find-lex (var)
  1356.     (let (found)
  1357.         (dolist (n *cleanup-forms-stack* nil)
  1358.             (if (eq (car n) 'LET)
  1359.                 (progn
  1360.                     (setq found (assoc var (cdr n)))
  1361.                     (if found (return-from find-lex found)))))))
  1362.  
  1363. (defun find-go-tag (var)
  1364.     (let (found)
  1365.         (dolist (n *cleanup-forms-stack* nil)
  1366.             (if (eq (car n) 'TAGBODY)
  1367.                 (progn
  1368.                     (setq found (assoc var (cdr n)))
  1369.                     (if found (return-from find-go-tag found)))))))
  1370.  
  1371. ;;
  1372. ;;    find-go-tag-tagbody
  1373. ;;    Returns the cleanup form for the TAGBODY block which contains the 
  1374. ;;    passed tag.
  1375. ;;
  1376. (defun find-go-tag-tagbody (var)
  1377.     (let (found)
  1378.         (dolist (n *cleanup-forms-stack* nil)
  1379.             (if (eq (car n) 'TAGBODY)
  1380.                 (progn
  1381.                     (setq found (assoc var (cdr n)))
  1382.                     (if found (return-from find-go-tag-tagbody n)))))))
  1383.  
  1384. (defun find-block (name)
  1385.     (dolist (n *cleanup-forms-stack* nil)
  1386.         (if (eq (car n) 'BLOCK)
  1387.             (if (eq (cadr n) name)
  1388.                 (return-from find-block n)))))
  1389.  
  1390. (defun find-any-block ()
  1391.     (dolist (n *cleanup-forms-stack* nil)
  1392.         (if (eq (car n) 'BLOCK)
  1393.             (return-from find-any-block n))))
  1394.  
  1395. ;;
  1396. ;;    required-arguments
  1397. ;;    Returns a list of the required arguments in a lambda list.
  1398. ;;
  1399. (defun required-arguments (lambda-list)
  1400.     (let ((arglist nil))
  1401.         (dolist (n lambda-list)
  1402.             (if (member n *lambda-list-keywords*)
  1403.                 (return)        ;; exit dolist loop
  1404.                 (push n arglist)))
  1405.         (reverse arglist)))
  1406.  
  1407. ;;
  1408. ;;    optional-arguments
  1409. ;;    Returns a list of the optional arguments in a lambda list.
  1410. ;;
  1411. (defun optional-arguments (lambda-list)
  1412.     (let ((arglist nil))
  1413.         (dolist (n (cdr (member '&optional lambda-list)))
  1414.             (if (member n *lambda-list-keywords*)
  1415.                 (return)        ;; exit dolist loop
  1416.                 (push n arglist)))
  1417.         (reverse arglist)))
  1418.  
  1419. ;; we don't need this
  1420. ;;
  1421. ;;(defun get-supplied-p-args (lambda-list)    
  1422. ;;    (let ((args nil) (forms (optional-arguments lambda-list)))
  1423. ;;        (dolist (f forms)
  1424. ;;            (if (>= (length f) 3)
  1425. ;;                (push (list (caddr f) nil) args)))
  1426. ;;        (reverse args)))                
  1427.  
  1428. ;;
  1429. ;;    rest-arguments
  1430. ;;    Returns a list of the rest arguments in a lambda list.
  1431. ;;
  1432. (defun rest-arguments (lambda-list)
  1433.     (let ((arglist nil))
  1434.         (dolist (n (cdr (member '&rest lambda-list)))
  1435.             (if (member n *lambda-list-keywords*)
  1436.                 (return)        ;; exit dolist loop
  1437.                 (push n arglist)))
  1438.         (reverse arglist)))
  1439.         
  1440. ;;
  1441. ;;    key-arguments
  1442. ;;    Returns a list of the optional key in a lambda list.
  1443. ;;
  1444. (defun key-arguments (lambda-list)
  1445.     (let ((arglist nil))
  1446.         (dolist (n (cdr (member '&key lambda-list)))
  1447.             (if (member n *lambda-list-keywords*)
  1448.                 (return)        ;; exit dolist loop
  1449.                 (push n arglist)))
  1450.         (reverse arglist)))
  1451.         
  1452. ;;
  1453. ;;    aux-arguments
  1454. ;;    Returns a list of the aux arguments in a lambda list.
  1455. ;;
  1456. (defun aux-arguments (lambda-list)
  1457.     (let ((arglist nil))
  1458.         (dolist (n (cdr (member '&aux lambda-list)))
  1459.             (if (member n *lambda-list-keywords*)
  1460.                 (return)        ;; exit dolist loop
  1461.                 (push n arglist)))
  1462.         (reverse arglist)))
  1463.         
  1464.  
  1465. ;;
  1466. ;;    kill-multiple-values
  1467. ;;    Use this function to make sure that ignored multiple values don't stick
  1468. ;;    around through successive evaluations.
  1469. ;;
  1470. (defun kill-multiple-values ()
  1471.     [
  1472.         `(clr.l (common-lisp::%multiple-values-address))
  1473.     ])
  1474.  
  1475. (defun compile-nil () 
  1476.     [ `(move.l 'nil d3) ]
  1477.     (setq *last-call-was-values* nil))
  1478.  
  1479. (defun valid-lambda (x)
  1480.     (and (listp x) (> (length x) 2) (eq (car x) 'lambda) (listp (cadr x))))
  1481.  
  1482. (defun find-lambdas (x)
  1483.     (cond ((not (consp x)) nil)
  1484.           ((valid-lambda x) (list x))
  1485.           (t (append (find-lambdas (car x)) (find-lambdas (cdr x))))))
  1486.  
  1487. (defun add-lexical-variables (varlist)
  1488.     (push-cleanup (cons 'LET varlist)))
  1489.  
  1490. (defun search-lambdas (var lambdas)
  1491.     (cond ((null lambdas) nil)
  1492.           ((eq var lambdas) var)
  1493.           ((atom lambdas) nil)
  1494.           ((search-lambdas var (car lambdas)))
  1495.           ((search-lambdas var (cdr lambdas)))))
  1496.           
  1497. (defun referenced-by-embedded-lambdas (var)
  1498.     (search-lambdas var *embedded-lambdas*))
  1499.     
  1500. (defun create-runtime-bindings ()
  1501.     (if *embedded-lambdas*
  1502.         (dolist (n *cleanup-forms-stack*)
  1503.             (if (eq 'LET (car n))
  1504.                 (dolist (m (cdr n))
  1505.                     (let* ((sym (car m)) 
  1506.                            (index (cdr m)))
  1507.                         (if (and (integerp index) 
  1508.                                 (referenced-by-embedded-lambdas sym))
  1509.                             (progn 
  1510.                                 (setf (cdr m) (list index))
  1511.                                 (push sym *environment*)
  1512.                                 [
  1513.                                     ;; add a heap binding for the variable
  1514.                                     `(move.l 0 (-a7))
  1515.                                     `(move.l (a3 ,(* index 4)) (-a7))
  1516.                                     `(move.l ',sym (-a7))
  1517.                                     `(move.l a7 (-a7))
  1518.                                     `(jsr #'cons)
  1519.                                     `(lea (a7 16) a7)
  1520.                                     `(move.l d0 (a3 ,(* index 4)))
  1521.                                 ]))))))))
  1522.  
  1523. ;;
  1524. ;;    export-environment()
  1525. ;;    d3 points to the function to receive the environment
  1526. ;;
  1527. (defun export-environment ()
  1528.     ;; first copy our heap environment
  1529.     [
  1530.         `(move.l 0 (-a7))
  1531.         `(move.l a4 (-a7))        ;; our environment
  1532.         `(move.l d3 (-a7))        ;; target function
  1533.         `(move.l a7 (-a7))
  1534.         `(jsr #'%function-environment)    ;; copy it
  1535.         `(lea (a7 16) a7)
  1536.         
  1537.         ;; now get the target environment in d0
  1538.         `(move.l 0 (-a7))
  1539.         `(move.l d3 (-a7))        ;; target function
  1540.         `(move.l a7 (-a7))
  1541.         `(jsr #'%function-environment)    ;; get its environment
  1542.         `(lea (a7 12) a7)        
  1543.     ]
  1544.     
  1545.     ;; now add all our current heap bindings
  1546.     (if *embedded-lambdas*
  1547.         (dolist (n *cleanup-forms-stack*)
  1548.             (if (eq 'LET (car n))
  1549.                 (dolist (m (cdr n))
  1550.                     (let* ((sym (car m)) 
  1551.                            (index (cdr m)))
  1552.                         (if (consp index)
  1553.                             [
  1554.                                 ;; add the binding to the target environment
  1555.                                 `(move.l 0 (-a7))
  1556.                                 `(move.l (a3 ,(* (car index) 4)) (-a7))
  1557.                                 `(move.l d0 (-a7))
  1558.                                 `(move.l a7 (-a7))
  1559.                                 `(jsr #'%environment-add-binding)
  1560.                                 `(lea (a7 16) a7)
  1561.                             ])))))))
  1562.     
  1563.  
  1564. (in-package :common-lisp-user)
  1565.  
  1566.  
  1567.  
  1568.  
  1569.  
  1570.